home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-11 / mpack.zip / MPACK.PRG < prev   
Text File  |  1993-01-04  |  4KB  |  163 lines
  1. * MemoPak3 is a Clipper UDF to pack the DBT associated with a DBF.
  2. * This function requires the name of the DBF and a name to use for the
  3. * temporary index that will be created. It only works on files with 1
  4. * memo field and will lose and or corrupt all of the data associated
  5. * with all memo fields other than the first.  The main advantage of
  6. * this function over the more standard COPY TO; DELETE; RENAME, syntax,
  7. * is that it uses less disk space than the COPY TO method
  8. * This version even seems to have the advantage 
  9. * of being faster than the COPY TO method.
  10. *
  11. *   Ira Emus
  12. *   irae  BIX
  13. *   Sep. 18, 1988
  14. *   memopak3("filename",'indxname')
  15.  
  16.  
  17. FUNCTION memopak3
  18.  
  19.     PARAMETER file2pack,ntxname
  20.     dbfname = TRIM(file2pack)+".dbf"
  21.     dbtname = TRIM(file2pack)+".dbt"
  22.      pkoffset = 0
  23.     pkname = getmemoname(dbfname,@pkoffset)
  24.  
  25.     memo2chr(dbfname,pkoffset)
  26.     SELE 0
  27.     USE (file2pack) ALIAS f2pack
  28.  
  29.     INDEX ON &pkname TO &ntxname
  30.     *
  31.     * Find the first memofield
  32.     *
  33.     SET SOFTSEEK ON
  34.     SEEK "         1"
  35.  
  36.     dbtnum = FOPEN(dbtname,2)
  37.     *
  38.     * cur_pos is the current offset into the .dbt file where the next memofield
  39.     * will be written.  The actual offset will be cur_pos * 512.
  40.     *
  41.     cur_pos = 1
  42.     buffer1 = space(512)
  43.     writeit = 512
  44.     DO WHILE !EOF()
  45.         *
  46.         * The location of the memofield attached to the current record is
  47.         * determined by looking at the contents of the memo field in the
  48.         * database and multipling by 512
  49.  
  50.  
  51.         where = (512*val(&pkname))
  52.         counter = 1
  53.         do while .T. 
  54.             FSEEK(dbtnum,where,0)
  55.             fread(dbtnum,@buffer1,512)             
  56.             FSEEK(dbtnum,writeit,0)
  57.             FWRITE(dbtnum,@buffer1,512)
  58.             writeit = writeit+512
  59.             if chr(26) $ buffer1
  60.                 exit
  61.             endif
  62.              where = where+512
  63.             counter=counter+1
  64.         ENDDO
  65.         REPLACE &pkname WITH str(cur_pos,10)
  66.          cur_pos = cur_pos + counter
  67.         SKIP
  68.     ENDDO
  69.     CLOSE DATA
  70.     cur_pos = cur_pos+1
  71.     FWRITE(dbtnum,'',0)
  72.     FSEEK(dbtnum,0,0)
  73.     FWRITE(L2BIN(cur_pos))
  74.     FCLOSE(dbtnum)
  75.     chr2memo(dbfname,pkoffset)
  76.     RETURN .T.
  77.  
  78.  
  79. FUNCTION getmemoname
  80.  
  81.     * This function will return the name of the first memo field, or an empty
  82.      * string if there is no memo field found and will put the offset into 
  83.     * the file of the field type identifier into the passed parameter offset.
  84.     * The parameter offset MUST be passed by reference and 
  85.   * must have been previously declared to a numeric 
  86.     *
  87.     * fieldname = getmemoname(filename,@offset)
  88.     *
  89.  
  90.     PARAMETER filename,offset
  91.     handle = FOPEN(filename,2)
  92.     test = FREADSTR(handle,1)
  93.     IF "â" = test
  94.         FSEEK(handle,8,0)
  95.         headlen = SPACE(2)
  96.         FREAD(handle,@headlen,2)
  97.         headlen = BIN2W(headlen)
  98.         offset = 43
  99.         FSEEK(handle,offset,0)
  100.         test = FREADSTR(handle,1)
  101.         DO WHILE test  # 'M' .AND. headlen > offset
  102.             offset = offset+ 32
  103.             FSEEK(handle,offset,0)
  104.             test = FREADSTR(handle,1)
  105.         ENDDO
  106.         IF test = "M"
  107.             FSEEK(handle,offset-11,0)
  108.             fieldname = space(10)
  109.             FREAD(handle,@fieldname,10)
  110.             FCLOSE(handle)
  111.             RETURN substr(fieldname,1,at(chr(0),fieldname)-1)
  112.         ENDIF
  113.     ENDIF
  114.     RETURN ""
  115.  
  116. FUNCTION memo2chr
  117.  
  118.     * This function given an offset and a filename will change the specified
  119.     * location to a "C" and change the header to indicate NO associated DBT.
  120.     * The offset should have been obtained with getmemoname.
  121.     *
  122.     * memo2chr(filename,offset)
  123.     *
  124.  
  125.     PARAMETER filename,offset
  126.     handle = FOPEN(filename,2)
  127.     test = FREADSTR(handle,1)
  128.     IF "â" = test
  129.         FSEEK(handle,0,0)
  130.         FWRITE(handle,"")
  131.         FSEEK(handle,offset,0)
  132.         FWRITE(handle,"C")
  133.         FCLOSE(handle)
  134.         RETURN .T.
  135.     ENDIF
  136.     RETURN .F.
  137.  
  138.  
  139.  
  140. FUNCTION chr2memo
  141.  
  142.     * This function given an offset and a filename will change the specified
  143.     * location to a "M" and change the header to indicate that there is an
  144.     * associated DBT.
  145.     * The offset should have been obtained with getmemoname.
  146.     *
  147.     * chr2memo(filename,offset)
  148.     *
  149.  
  150.     PARAMETER filename,offset
  151.     handle = FOPEN(filename,2)
  152.     FWRITE(handle,"â")
  153.     FSEEK(handle,offset,0)
  154.     test = FREADSTR(handle,1)
  155.     IF test = "C"
  156.         FSEEK(handle,offset,0)
  157.         FWRITE(handle,"M")
  158.         FERROR()
  159.         FCLOSE(handle)
  160.         RETURN offset
  161.     ENDIF
  162.     RETURN -1
  163.